perm filename MATCH.LSP[C,JRA]1 blob
sn#012878 filedate 1972-11-15 generic text, type T, neo UTF8
00100 (GLOBAL
00200 (FUNCTIONS MATCH ASSIGNED?)
00300 (RESERVED /!> /!< /!/' /!? /!/; /!/,))
00400
00500 (DECLARE (SYMBOLS T) (GENPREFIX '\M) (GENSYM 'M)
00600 (SPECIAL MALIST MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND VALV)
00700 (*LEXPR MATCH TRYASSIGN RVALUE VLOC)
00800 (*FEXPR CERR))
00900
01000 (DEFUN MATCH N
01100 ((LAMBDA (VARPAT DATAPAT)
01200 (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
01300 (COND ((> N 2)
01400 (SETQ MALIST1 (ARG 3) MALIST2 (ARG 4) NOBIND T)) )
01500 (SETQ MALISTV1 (GET 'MALIST1 'VALUE)
01600 MALISTV2 (GET 'MALIST2 'VALUE))
01700 (RETURN (COND ((MATCH1 VARPAT DATAPAT)
01800 (LIST MALIST1 MALIST2)) )) ))
01900 (ARG 1)
02000 (ARG 2) ))
02100
02200 (DECLARE (UNSPECIAL MALIST1 MALIST2)) (DEFUN MATCH1 (VARPAT DATAPAT)
02300 (PROG (ACTOR1 ACTOR2)
02400 (RETURN
02500 (COND ((ATOM VARPAT) (MATCH2 DATAPAT VARPAT MALISTV2))
02600 ((ATOM DATAPAT) (MATCH2 VARPAT DATAPAT MALISTV1))
02700 ((EQ (SETQ ACTOR2 (CAR DATAPAT)) '/!/'))
02800 ((MEMQ ACTOR2 '(/!< /!/?))
02900 (MATCH2 VARPAT (ACTORSUBST DATAPAT (CDR MALISTV2)) MALISTV1))
03000 ((EQ (SETQ ACTOR1 (CAR VARPAT)) '/!>)
03100 (/!> (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
03200 ((EQ ACTOR1 '/!/?)
03300 (/!/? (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T))
03400 ((EQ ACTOR1 '/!/')
03500 (MBINDR (CADR VARPAT) (CDDR VARPAT) DATAPAT MALISTV1))
03600 ((EQ ACTOR1 '/!<)
03700 (/!< (CADR VARPAT) DATAPAT MALISTV1 MALISTV2))
03800 ((EQ ACTOR1 '/!/,)
03900 (COMMA (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
04000 ((EQ ACTOR1 '/!/;)
04100 (/!/; (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T))
04200 ((EQ ACTOR2 '/!>)
04300 (/!/? (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL))
04400 ((EQ ACTOR2 '/!/;)
04500 (/!/; (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL))
04600 ((EQ ACTOR2 '/!/,)
04700 (COMMA (CDR DATAPAT) VARPAT MALISTV2 MALISTV1))
04800 ((MATCH1 (CAR VARPAT) (CAR DATAPAT))
04900 (MATCH1 (CDR VARPAT) (CDR DATAPAT))) )) ))
05000
05100 (DECLARE (UNSPECIAL MALISTV2)) (DEFUN COMMA (VARSPEC DATAPAT MV1 MV2)
05200 ((LAMBDA (VAR VALSPEC)
05300 (COND (VALSPEC
05400 ((LAMBDA (VAL)
05500 (COND ((MATCH2 DATAPAT VAL MV2)
05600 (MBINDV VAR VAL MV1)) ))
05700 ((LAMBDA (MALIST) (EVAL (CAR VALSPEC)))
05800 (CDR MV1))))
05900 (((LAMBDA (VAL)
06000 (COND ((EQ VAL '*UNASSIGNED)
06100 (TRYASSIGN VAR DATAPAT (CDR MV1) MV2 (EQ MV1 MALISTV1) NIL))
06200 ((MATCH2 DATAPAT VAL MV2)) ))
06300 ((LAMBDA (MALIST) (/!/,1 VAR)) (CDR MV1)))) ))
06400 (CAR VARSPEC)
06500 (CDR VARSPEC)) )
06600
06700 (DECLARE (UNSPECIAL MALISTV1))
06800
06900
07000 (DEFUN MATCH2 (VARPAT EXP MV)
07100 (COND ((ATOM VARPAT) (EQUAL VARPAT EXP))
07200 (((LAMBDA (ACTOR)
07300 (COND ((MEMQ ACTOR '(/!/? /!> /!/'))
07400 (MBINDR (CADR VARPAT) (CDDR VARPAT) EXP MV))
07500 ((EQ ACTOR '/!/,)
07600 ((LAMBDA (VAR VALSPEC)
07700 (COND (VALSPEC
07800 ((LAMBDA (VAL)
07900 (COND ((EQUAL VAL EXP)
08000 (MBINDV VAR EXP MV)) ))
08100 ((LAMBDA (MALIST) (EVAL (CAR VALSPEC)))
08200 (CDR MV))))
08300
08400 (((LAMBDA (VAL)
08500 (COND ((EQ VAL '*UNASSIGNED)
08600 (MSET VAR EXP (CDR MV)))
08700 ((EQUAL VAL EXP)) ))
08800 ((LAMBDA (MALIST) (/!/,1 VAR))
08900 (CDR MV)))) ))
09000 (CADR VARPAT)
09100 (CDDR VARPAT)))
09200 ((EQ ACTOR '/!/;)
09300 (PROG (VAR VALV RS)
09400 (SETQ VAR (CADR VARPAT) RS (CDDR VARPAT))
09500 (RETURN
09600 (COND ((SETQ VALV (ASSQ VAR (CDR MV)))
09700 (AND (COND ((EQ (SETQ VALV (CADR VALV)) '*UNASSIGNED)
09800 (MSET VAR EXP (CDR MV)))
09900 ((EQUAL VALV EXP)) )
10000 (SATISFY RS (CDR MV))))
10100 ((CHECKVAL VAR)
10200 (AND (EQUAL VALV EXP)
10300 (SATISFY RS (CDR MV))))
10400 ((MBINDR VAR RS EXP MV)) )) ))
10500 ((EQ ACTOR '/!<) NIL)
10600 ((ATOM EXP) NIL)
10700 ((MATCH2 ACTOR (CAR EXP) MV)
10800 (MATCH2 (CDR VARPAT) (CDR EXP) MV)) ))
10900 (CAR VARPAT))) )) (DEFUN /!/? (VARSPEC PAT VALISTV PALISTV VARSALLOWED)
11000 ((LAMBDA (VAR RS VARS)
11100 (COND (VARS
11200 (COND ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
11300 (COND ((HASVARS VARS) (MBINDV VAR '*UNASSIGNED VALISTV))
11400 ((OR (NOT VAR)
11500 (MBINDR VAR RS (VARSUBST PAT (CDR PALISTV)) VALISTV))) )) ))
11600 (T (MBINDR VAR RS PAT VALISTV)) ))
11700 (CAR VARSPEC)
11800 (CDR VARSPEC)
11900 (FINDVARS PAT PALISTV)) )
12000
12100
12200 (DEFUN /!> (VARSPEC PAT VALISTV PALISTV)
12300 ((LAMBDA (VAR RS VARS)
12400 (COND (VARS
12500 (COND ((HASVARS VARS) NIL)
12600 (T (OR (NOT VAR)
12700 (MBINDR VAR RS (VARSUBST PAT (CDR PALISTV)) VALISTV))) ))
12800 (T (MBINDR VAR RS PAT VALISTV)) ))
12900 (CAR VARSPEC)
13000 (CDR VARSPEC)
13100 (FINDVARS PAT PALISTV)) )
13200
13300
13400 (DEFUN TRYASSIGN N
13500 ((LAMBDA (VARS VAR PAT MALIST PALISTV VARSALLOWED RS)
13600 (COND (VARS
13700 (COND ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
13800 (COND ((HASVARS VARS))
13900 (T ((LAMBDA (VAL)
14000 (MSET VAR VAL MALIST)
14100 (SATISFY RS MALIST))
14200 (VARSUBST PAT (CDR PALISTV)))) )) ))
14300 (T (MSET VAR PAT MALIST) (SATISFY RS MALIST)) ))
14400 (FINDVARS (ARG 2) (ARG 4)) (ARG 1) (ARG 2) (ARG 3) (ARG 4) (ARG 5) (ARG 6)) )
14500
14600
14700
14800 (DEFUN /!< (VAR PAT VALISTV PALISTV)
14900 ((LAMBDA (VARS)
15000 (COND (VARS
15100 (COND ((HASVARS VARS)
15200 (OR (NOT VAR)
15300 (MBIND VAR (VARSUBST PAT (CDR PALISTV)) VALISTV))) )) ))
15400 (FINDVARS PAT PALISTV)) ) (DEFUN /!/; (VARSPEC PAT VALISTV PALISTV MUSTBIND)
15500 (PROG (VAR VALV RS)
15600 (SETQ VAR (CAR VARSPEC) RS (CDR VARSPEC))
15700 (RETURN
15800 (COND ((SETQ VALV (ASSQ VAR (CDR VALISTV)))
15900 (COND ((EQ (SETQ VALV (CADR VALV)) '*UNASSIGNED)
16000 (TRYASSIGN VAR PAT (CDR VALISTV) PALISTV MUSTBIND RS))
16100 ((MATCH2 PAT VALV PALISTV) (SATISFY RS (CDR VALISTV))) ))
16200 ((CHECKVAL VAR)
16300 (AND (MATCH2 PAT VALV PALISTV) (SATISFY RS (CDR VALISTV))))
16400 (MUSTBIND
16500 (/!> VARSPEC PAT VALISTV PALISTV))
16600 ((/!/? VARSPEC PAT VALISTV PALISTV NIL)) )) ))
16700
16800
16900 (DEFUN CHECKVAL (VAR)
17000 (COND ((SETQ VALV (VLOC VAR))
17100 (NOT (EQ (SETQ VALV (CADR VALV)) '*UNASSIGNED)))
17200 ((SETQ VALV (BOUNDP VAR))
17300 (NOT (EQ (SETQ VALV (CDR VALV)) '*UNASSIGNED))) ))
17400
17500 (DECLARE (UNSPECIAL VALV)) (DEFUN FINDVARS (PAT MALISTV)
17600 (COND ((ATOM PAT) NIL)
17700 (((LAMBDA (CAR)
17800 (COND ((EQ CAR '/!/,)
17900 ((LAMBDA (VAR VALSPEC)
18000 (COND ((OR (NULL VALSPEC) NOBIND)
18100 (GETSPEC '/!/, VAR (CDR MALISTV)))
18200 ((MBINDV VAR
18300 ((LAMBDA (MALIST)
18400 (EVAL (CAR VALSPEC)))
18500 (CDR MALISTV))
18600 MALISTV)
18700 (LIST 'NIL)) ))
18800 (CADR PAT)
18900 (CDDR PAT)))
19000 ((EQ CAR '/!/;)
19100 ((LAMBDA (VAR MALIST)
19200 (COND ((ASSIGNED? VAR) (LIST NIL))
19300 ((OR NOBIND (ASSQ VAR MALIST))
19400 (GETSPEC '/!/; VAR MALIST))
19500 ((MBINDV VAR '*UNASSIGNED MALISTV)
19600 (LIST '/!>)) ))
19700 (CADR PAT)
19800 (CDR MALISTV)))
19900 ((ACTOR CAR)
20000 (COND (NOBIND (GETSPEC CAR (CADR PAT) (CDR MALISTV)))
20100 ((MBINDV (CADR PAT) '*UNASSIGNED MALISTV)
20200 (LIST CAR)) ))
20300 ((NCONC (FINDVARS CAR MALISTV)
20400 (FINDVARS (CDR PAT) MALISTV))) ))
20500 (CAR PAT))) ))
20600
20700
20800 (DEFUN HASMUSTASSIGNS (VARS)
20900 (DO V VARS (CDR V) (NULL V)
21000 (AND (MEMQ (CAR V) '(/!> /!/')) (RETURN T)) ))
21100
21200
21300 (DEFUN HASVARS (VARS)
21400 (DO V VARS (CDR V) (NULL V)
21500 (AND (CAR V) (RETURN T)) ))
21600
21700
21800 (DEFUN VARSUBST (PAT MALIST)
21900 (COND ((ATOM PAT) PAT)
22000 ((ACTOR (CAR PAT))
22100 (ACTORSUBST PAT MALIST))
22200 ((CONS (VARSUBST (CAR PAT) MALIST)
22300 (VARSUBST (CDR PAT) MALIST))) ))
22400
22500
22600 (DEFUN ACTOR (ATOM)
22700 (MEMQ ATOM '(/!> /!/? /!/' /!< /!/, /!/;)) )
22800
22900
23000 (DEFUN ACTORSUBST (PAT MALIST)
23100 ((LAMBDA (VAR)
23200 ((LAMBDA (VAL)
23300 (COND ((EQ VAL '*UNASSIGNED) PAT) (VAL) ))
23400 (/!/,1 VAR)))
23500 (CADR PAT)) )
23600
23700
23800 (DEFUN GETSPEC (ACTOR VAR MALIST)
23900 (COND ((EQ (/!/,1 VAR) '*UNASSIGNED)
24000 (COND (NOBIND (CERR UNASSIGNED VARIABLE IN INSTANCE))
24100 ((LIST ACTOR)) ))
24200 ((LIST NIL)) )) (DEFUN MBIND (VAR VAL ALISTV)
24300 (COND (NOBIND (MSET VAR VAL (CDR ALISTV)))
24400 ((RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV)))) ))
24500
24600
24700 (DEFUN MBINDV (VAR VAL ALISTV)
24800 (COND ((NOT VAR))
24900 (NOBIND (MSET VAR VAL (CDR ALISTV)))
25000 ((RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV)))) ))
25100
25200 (DECLARE (UNSPECIAL NOBIND))
25300
25400
25500 (DEFUN MBINDR (VAR RESTRICTIONS VAL ALISTV)
25600 (OR (NOT VAR)
25700 (AND (MBIND VAR VAL ALISTV)
25800 (SATISFY RESTRICTIONS (CDR ALISTV)))) )
25900
26000
26100 (DEFUN /!/, FEXPR (L) (/!/,1 (CAR L)))
26200
26300
26400 (DEFUN /!/,1 (VAR/ )
26500 ((LAMBDA (PAIR)
26600 (COND (PAIR (CADR PAIR)) ((RVALUE VAR/ )) ))
26700 (ASSQ VAR/ MALIST)) )
26800
26900
27000 (DEFUN SATISFY (RS MALIST)
27100 (OR (NULL RS)
27200 (APPLY 'AND RS)) )
27300
27400 (DECLARE (UNSPECIAL MALIST))
27500
27600
27700 (DEFUN MSET (VAR VAL MALIST)
27800 ((LAMBDA (PAIR)
27900 (COND (PAIR (RPLACA (CDR PAIR) VAL) VAL)
28000 ((CERR VARIABLE @VAR UNBOUND IN MATCH ALIST)) )
28100 T)
28200 (ASSQ VAR MALIST)) )
28300
28400
28500 (DEFUN ASSIGNED? (VAR)
28600 (PROG (VAL)
28700 (RETURN
28800 (COND ((SETQ VAL (VLOC VAR)) (NOT (EQ (CADR VAL) '*UNASSIGNED)))
28900 ((SETQ VAL (BOUNDP VAR)) (NOT (EQ (CDR VAL) '*UNASSIGNED))) )) ))